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SERVER SOURCE 



readme 

1 Connectivity between the various Perl files 

2 (1) ci.pl 

3 project.pl 

4 host.pl 

5 getsessionid.pl 

6 project.pl 

7 webdate.pl 

8 -> acceptdecline.pl (by way of form submission) 

9 acceptdecline.pl 

10 cgi.pl 

11 getsessionid.pl 

12 project.pl . . . 

13 -> (2a) declined.html OR 

14 -> (2b) ci.pl 

15 (3) save.pl 

16 getsessionid.pl 

17 (4) calculate.pl 

18 project .pi ... 

19 getsessionid.pl ... 

20 -> (4a) overuse.html OR 

21 -> (4b) getresults.pl (by way of MET A refresh) 

22 (5) getresults.pl 

23 getsessionid.pl ... 

24 calculate2.pl 

25 project .pi . . . 

26 getsessionid.pl ... 

27 readstuff.pl 

28 project.pl (?!) 

29 getsessionid.pl (?!) 

30 ansof t_f iles .pi 

31 remoteTLINE.pl 

32 getheadpost.pl 

all_md5 

1 MD5 checksums 

2 c4616dce3206bfbaleld26e910fcdal9 readme 

3 f 627deb66f f 95612e34bbc2 840b4406 9 all_md5 

4 2f 7 3d693dl3e2de292c2a9al7b09bb40 acceptdecline.pl 

5 d4d66bd7 8c7e3d244a844dc8c6568d83 calculate.pl 

6 4f Oef 466c56dbf48f 431045b3c6b65af calculate2 . pi 

7 a23e9322 9c5cd96f 44ed6bf a8cb4 3923 cgi.pl 

8 3dd2bd09c6af 8 21ac9489471e0140b51 ci.pl 

9 5f 6136da8fbc267052ed9a6elfcd86c4 getresults .pi 

10 7889f 9cab37 87db2b0a4231ecl28a331 getsessionid.pl 

11 a92 6a04 944ceeeecaf 8c5ba09675aa46 host.pl 

12 C04024bba78bf2e5dalfc944f3c083e2 makeauth.pl 

13 ccf4d0e44f 6b7b5fa920e23ae022d46b project.pl 

14 f 62c027 1487 6d46 8 6del 13973 9abccdf save.pl 

15 d30alca9731e7feccf 5922c 1681 192dc webdate.pl 

16 C2898185d40e61d3e8f98add70d2 6f4a native_CrossSection.html 

17 2daeb6d25d7d4ffe52ed835721512f56 nav3_CrossSection.html 

18 cf20dclf 37dclcl012fdf 7fccb8117dl . . / . . /html/ Stackup/declined.html 
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19 90d33ac8912a6b25c3332b34decl4e71 . ./. . /html/ St ackup/ error . html 

20 cdl410f 9391b66a64abe3f 0368f 72e66 . ./• . /html/ Stackup/overuse . html 

acceptdecline .pi 

1 #! /usr/bin/perl 

2 use strict; 

3 my $debug; 

4 #$debug = 1; m ^ 

5 if ($debug) { print "Content-Type: text/ html\n\n<HTML><BODY><PRE> ; } 

6 require ( "cgi.pl" ) ; 

7 # GLOBAL S 

8 use vars qw( $debug ); 

9 require ( "getsessionid.pl" ) ; 

10 use vars qw ( $suid $user_id $usage $path_info $save_copy $cookie); 

11 my lvalues = &process__form( ) ; 

12 my $time = hex( &obscure( substr ($ values { "token" } , 0 , 8 ) , 
: 13 substr ($values{ "token"}, 8, 8) ) ); 
! 14 my $delay = $time+15-time ( ) ; 

I 15 if ($debug) { print "time: $time delay: $delay\n"; } 

i 16 require ( "project .pi" ) ; 

17 use vars qw( $H0ST_IP) ; 

18 use vars qw($PROJECT $USAGE_MAX $USAGE_INTERVAL $RECORD_LENGTH 
$NUM__RECORDS ) ; 

19 if ($values{ "choice"} =~ /ACCEPT/) { 

20 # if ($delay > 0) { sleep ( $delay ) ; } 

21 print "Location: http: //$HOST_IP/cgi-bin/$PROJECT/ci .pl\n" ; 

22 print "Pragma: no-cache\nExpires : Mon, 01 Jul 1996 00:00:00 GMT\n"; 

23 if ($delay > -300) { print $cookie; } 

24 print " \n" ; 

25 } 

26 else { 

27 print "Location: http: / /$HOST_IP/$PROJECT/declined.html\n ; 

28 print "Pragma: no-cache\nExpires : Mon, 01 Jul 1996 00:00:00 GMT\n"; 

29 print "\n"; 

30 } 

calculate .pi 

1 #! /usr/bin/ perl 

2 # calculate.pl 

3 # Copyright (C) 1999-2000 Rode Consulting, Inc. 

4 # All rights reserved. 

5 use strict; 

6 # GLOBAL S 

7 use vars qw( $debug ); 

8 #$debug = 1; 
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9 require ( "pro ject .pi " ) ; 

10 use vars qw( $HOST__IP ) ; 

11 use vars qw($PROJECT $USAGE__MAX $USAGE__INTERVAL $RECORD_LENGTH 
$NUM_RECORDS) ; 

12 require( "getsessionid.pl" ) ; 

13 use vars qw ( $suid $new_suid $user__id $timestamp $usage $valid 
$path_info $cookie); 

14 $USAGE_MAX=10; 

15 if ($usage >= $USAGE_MAX) { 

16 print "Location: http: //$H0ST_IP/$PR0JECT7 overuse . htmlXn" ; 

17 print n \n" ; 

18 exit(O); 

19 } 

20 #print "Location: http: // " , $H0ST_IP / , 7cgi-bin/$PR0JECT/calculate2 .pl\n" ; 

21 #print "\n" ; 

22 # 

; 23 # Rather than directly forward to the script that does the real 
, calculation 

"! 24 # We instead return a small HTML page that displays a message, before 

1 25 # forwarding to the final location. 

I 26 my $hash = &hash( $user_id) ; 

27 # Write new cookie to cookie cache 

I 28 sysopen(AUDIT_DB, "auth.dat", 2) or die ("Can't open authorization 
< database 1 " ) * f 

2 9 'sysseek( AUDIT_DB , $ hash* §RECORD_LENGTH , 0 ); 

3 0 my $written = syswrite( AUDIT_DB, ($new_suid."\n"), 

31 $RECORD_LENGTH ); 

32 die "System write error: $i\n" unless defined $written; 

33 close (AUDIT_DB) ; 

\ 34 print "Pragma: no-cache\nExpires : Hon, Ol-Jul-1996 00:00:00 GMT\n"; 

35 print $cookie; 

36 print "Content-Type: text/html\n\n" ; 
3 7 print «"EOF" 

38 <HTML><HEAD><TITLE>Extraction in progress .</TITLE> 

39 <META HTTP-EQUIV= u refresh n CONTENT^" 0 ; URL=http : / / $H0ST_IP/ cgi- 
bin/$PROJECT/getresults .pl M > 

40 <SCRIPT LANGUAGE=" JavaScript "><! — 

41 badbrowser = (( navigator . appName == "Microsoft Internet Explorer") 
&& (parselnt( navigator. appVers ion) ==4) && ( navigator . appVersion . indexOf ( "Mac " ) > 

0)); 

42 if (badbrowser) this . focus () ; 

43 if ('badbrowser && window. focus ) this . focus () ; 

44 //--></SCRIPT> 

45 </HEAD> 

46 <B0DY BGC0L0R="#FFFFFF" TEXT="#000000 " LINK-"#0000FF " VLINK="#AA00AA" 
ALINK="#FF0000"> 
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47 < TABLE VALIGN=CENTER WIDTH=" 100% " HEIGHT= 11 1 0 0 % " XTRXTD VALIGN=CENTER 
ALIGN=CENTER> 

48 <CENTER><H2>Please wait. . .<BR>Extraction in progress</H2X/CENTER> 

49 < / TD>< / TR>< / TABLE> 

50 </BODY> 

51 </HTML> 

52 EOF 

53 ? 

54 1; 

calculate2 .pi 

1 #! /usr/bin/perl 

2 # calculate2.pl 

3 # Copyright (C) 1998-2000 Rode Consulting, Inc. (RCI) 

4 # All rights reserved. 

5 use strict; 

6 # GLOBALS 

7 use vars qw( $debug ); 

8 #$debug = 1; 

9 if ($debug) { 

10 print "Content-Type: text/html\n n ; 

11 print "Pragma: no-cache\nExpires : Mon, 01 Jul 1996 00:00:00 GMT\n 

12 print "\n" ; 
13 

14 print "<BODYXPRE>\n" ; 

15 } 

1 6 require ( " pro j ec t . pi " ) ; 

17 use vars qw( $HOST_IP ) ; 

18 #use vars qw( $DOMAIN_NAME $HOST__NAME $HOST_IP $HOST_PREFIX 

$H0ST CGI PREFIX) ; 

19" #use vars qw( $HOST_PREFIX_JAVA $HOST_CGI_PREFIX_JAVA) ; 

20 #use vars qw($BODY $NOCACHE__HEADER $GS $JP2GIF $ ALCHEMY ) ; 

21 #use vars qw( %HTML_MACROS) ; 

22 use vars qw($PROJECT $USAGE_MAX $USAGE_INTERVAL ) ; 

23 require( "getsessionid.pl" ) ; 

24 use vars qw ( $suid $user_id $timestamp $usage $valid $path_info 
$cookie ) ; 

25 use vars qw( litems $user_id $root $dont__do_it $results); 

26 use vars qw( $units_name $units $scale ); 

2 7 my $LOCK_SH=l ; my $LOCK_EX=2 ; my $LOCK_NB=4 ; my $L0CK_UN=8; 

28 if ( !$dont_do_it && ($usage > $USAGE__MAX) ) { 

29 print "Location: http: //$HOST_IP/$PROJECT/overuse .html\n" ; 

30 print "\n"; 

31 exit(0); 

32 } 

33 if ( ! $dont_do__it && ( ( time ( ) -$timestamp ) > 15)) { 

34 print "Location: http : //$HOST_IP/$PROJECT/error . html\n" ; 
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35 print "\n"; 

36 exit(O); 

37 } 

38 # Retrieve the binary data from a file 

39 if ( $dont_do_it | | 

40 ($valid>0 && -e " tmp/stuf f " . $user__id. sprintf ( "%04d ,$usage)) ) { 

41 # require ( "readstuff.pl" ) ; 

42 # $root = "x.pjt"; 

43 # require ( "field_extractor_files.pl" ) ; 

44 # Early return for use with ez2dzip.pl 

45 # if ($dont_do_it) { return 1; } 

46 # open (LOCKFILE, "»tmp/lockf ile u ) ; 

47 # flock ( LOCKF ILE r $L0CK_EX); 

48 # seek { LOCKFILE , 0, 2); 

49 # require ( "remoteTLINE.pl" ) ; 

50 # flock (LOCKFILE, $L0CK_UN) ; 

51 # close ( LOCKFILE ) ; 

52 open(SAVE, ">tmp/results $user_id . sprintf ( "%04d" , $usage ) ) ; 

53 print SAVE "DUMMY" ; 

54 close SAVE; 

55 } 

56 else { 

57 print "Location: http: //$HOST_IP/$PROJECT/error .html\n\n ; 

58 exit 0; 

59 } 

60 1; 

cgi .pi 

1 # ' /usr/local/bin/perl 

2 #Copyright (C) 1996-8 Rode Consulting, Inc. All rights reserved. 

3 #package myCGI; 

4 use strict; 

5 # GLOBAL S: 

6 # $cgi_query: The query string (source depends on 

REQUEST_METHOD ) ~ 

7 # (logged by other scripts) 

8 # TEMP %form_values is global for compatibility 

9 # Special (evil?) mode flags: 

10 # $debug: Global cross-module debug flag 

H # $ cgi_lowercase: Form value names are all lowercased 

12 use vars qw($debug $_cgi_lowercase $cgi_query %f orm_values ) ; 

13 if ($debug) { print "cgi.pl called\n"; } 

14 # process_form( ) 

15 sub process_form { 

16 my ($valid,@pairs) = (" ",("")) ; 
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17 $| = l; 

18 if ($debug) { print "Method: ", $ENV{ ' REQUEST_METHOD ' } , "<BR>\n" ; 
} 

19 $valid = ""; 

2 0 if ( $ENV{ ' REQUEST_METHOD ' } eq 'GET') 

21 { 

22 $cgi_query = $ENV{ ' QUERY_STRING' } ; 

23 $ valid = ( $ENV{ ' QUERY_STRING ' } ) ? "true" : " " ; 

24 } 

25 elsif ( $ENV{ ' REQUEST_METHOD ' } eq 'POST') 

26 { 

27 $valid = ( $ENV{ ' CONTENT_LENGTH ' } > 0) ? "true" : "" ; 

28 if ($valid) { read(STDIN, $cgi_query, $ENV{ ' CONTENT_LENGTH ' } ) ; } 

29 $cgi_query =~ s/\n/\&/g; 

30 } 

31 elsif ($debug) { print "Unrecognized method: 
$ENV{ 'REQUEST_METHOD' }\n M ; } 

32 if ($debug) { print "CGI arguments: " , $cgi_query, "<BR>\n"; 
} 

33 if (Svalid) 

34 { 

35 @pairs = split(/&/, $cgi_query); 

36 foreach my $pair (@pairs) 

37 { 

38 $pair =~ s/\+\+/\+/g; 

39 $pair =~ s/\ + / /g; 

40 my ($name, $value) = split (/=/, $pair); 

41 $name =» s/% ( [ a-f A-FO-9 ] {2 } ) /pack( ' c ' , hex ( $1 ) ) /eg; 

42 $value =~ s/% ( [ a-f A-FO-9 ] {2 } ) /pack( ' c ' , hex ( $1 ) ) /eg; 

43 $value =- s/%2 [ Ff ] A//g; 

44 if ($_cgi_lowercase) { $name =- tr/A-Z/a-z/; } 

45 if ($form_values{$name} ) 

46 { $form_values{$name} .= . $value; } 

47 else 

48 { $form_values{$name} = $value; } 

49 if ($debug) { print $name, " = '", $ f orm_values{ $name} , 

"'\n"; } 

50 , } 

51 } 

52 %form_values; 

53 } 

54 # get_cookie( -cookiename- ) 

55 # Returns the first cookie by the given name 

56 sub get_cookie { 

57 my ($cookie) = @_; 

58 my (6 cookies, $cookieName / $cookieVal) = (("")/ " " , " " ) ; 

59 if ($debug) { print "HTTP_COOKIE : " , $ENV{ "HTTP_COOKIE " } , " \n" ; } 

60 if ($ENV{ ,, HTTP_COOKIE"} =- /$cookie/) 

62 { ^cookies = split (/; \s*/ , $ENV{ "HTTP^COOKIE "}) ; 
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63 if ($debug) { print '^cookies: ' , ^cookies , " \n" ; } 

64 

65 foreach (^cookies) 

66 { 

67 if ($_ =~ /$cookie/) 

68 { 

69 ( $cookieName, $cookieVal) = split (/=/,$_); 

70 return ( $cookieVal) ; 

71 } 

72 } 

73 } 

74 else { return(''); } 

75 } 

76 ##@LOOKUP = split (/Name:/ , 'nslookup $ENV{ "REMOTE_ADDR" } ' ) ; 

77 ##@LOOKUP = split (/Address:/, $LOOKUP[l]); 

78 ##$client_name = $LOOKUP[0]; 

79 #$client_name = $ENV{ "REMOTE_ADDR" } ; 

80 #$client_name =~ s/ //g; 

81 #package form; 

82 1; 

ci.pl 

4 1 #* /usr/bin/perl 

^ 2 use strict; 

3 # GLOBAL S 

: H 4 use vars qw( $debug ); 

5 my $ debug; 

Si 6 #$debug =1; t „ , 

O 7 if ($debug) { print "Content-Type: text/ html \n\n<HTML><BODY><PRE> ; } 

5** 8 require ( "project . pi" ) ; 

9 use vars qw( $DOMAIN_NAME $HOST_NAME $HOST__IP $HOST_PREFIX 

$HOST_CGI_PREFIX) ; 



10 use vars qw($PROJECT $USAGE_MAX $USAGE_INTERVAL $RECORD_LENGTH 
$NUM_RECORDS) ; 

11 require ( "getsessionid.pl " ) ; 

12 use vars qw ( $suid $user_id $usage $path_info $save_copy $cookie); 

13 if ($debug) { . 

14 print $suid," n ,$user_id," n ,$usage f " " , $path_inf o, ,$cookie; 

15 } 

16 print "Content-Type: text/ html \ n " ; 

17 print "Pragma: no-cache\nExpires : Mon, 01 Jul 1996 00:00:00 GMT\n ; 

18 print "\n"; 

19 if (length($suid) > 0) { 

2 0 if ( I ($ENV{ n HTTP_USER_AGENT"} =~ /3.0/) ) { 

21 open (HTML, "native_CrossSection.html" ) ; 

22 } 

23 else { open (HTML, "nav3_CrossSection, html " ) ; } 
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24 read(HTML, my $html, 1000000); 

25 close (HTML) ; 

26 $html =~ s/<HOST_IP>/$HOST_IP/g; 

2 7 print $html; 

28 } 

2 9 else { # New cookie 

30 open (DISCLAIMER, " . ./- . /html/netsim/termsof use .html" ) ; 

31 read (DISCLAIMER, my $disclaimer, 1000000); 

32 close (DISCLAIMER) ; 

33 my §time = sprintf ( " %08x" , time ( ) ) ; 

34 my $mask = substr ( &sumcheck( $time) , 0 , 8 ) ; 

35 my $token = &obscure ( $time, $mask) . $mask; 

36 $disclaimer =- s/<l— marker 1 — >/ \( Please read carefully then 
click <B>ACCEPT<\/B> or <B>DECLINE<\ /B> at the bottom of this page\ ) / ; 

37 my $replacement = «"EOF" 

38 "^CENTER^* 

39 <APPLET CODE="AcceptDecline. class" CODEBASE="http: //$HOSTJCP/$PROJECT/" 

WIDTH=250 HEIGHT=40> 

40 <PARAM NAME=token VALUE=" $ token "> 

41 </APPLET> 

42 </CENTER> 
4 3 EOF 

44 ; 

45 ^disclaimer =~ s/<!~ marker2 -->/$replacement/ ? 

46 print $disclaimer; 

47 } 

4 8 exit(0); 

getresults . pi 

1 #! /usr/bin/perl 

2 use strict; 

3 require ( "getsessionid.pl" ) ; 

4 use vars qw( $debug ); _ 

5 use vars qw ( $suid $new_suid $user_id $usage $path_mfo $save_copy 

$cookie) ; 

6 my $results_filename = "tmp/results" .$user_idi. sprintf ( "%04d" ,$usage) ; 

7 if (i (-e $results_f ilename) ) { 

8 open ( SAVE , ">$results_f ilename" ) ; 

9 close (SAVE); 

10 require "calculate2.pl"; 

11 } 

12 print "Content-Type: text/html\n" ; 

13 print "Pragma: no-cache\nExpires : Mori, 01 Jul 1996 00:00:00 GMT\n ; 

14 print "\n"; 

15 print ,! <HTML><HEAD>\n" ; 

16 print "<TITLE>Field Extraction Results</TITLE>\n" ; 
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17 print "<SCRIPT LANGUAGE=\ "JavaScript \">< I —\n" ; 

18 print " badbrowser = ( (navigator. appName == \ n Microsoft Internet 
ExplorerV) && ( par selnt ( navigator . appVersion) === 4) && 

( navigator . appVers ion. indexOf (V'MacV ) > 0));\n"; 

19 print " if (badbrowser) this . focus (); \n" ; 

20 print " if ('badbrowser && window. focus ) this . focus (); \n" ; 

21 print " //-- -></SCRIPT>\n" ; 

22 print "<STYLE TYPE=\ "text/ css\ ">\nBODY { font-size : lOpt }\n HI 

{ font-size :24pt }\n H2 { font-size : 20pt }\n H3 { font-size : 16pt 
}\n TABLE { font-size : lOpt }\n TD { font-size : lOpt } \n</STYLE>\n " ; 

23 print ' </HEAD> ' ; 

24 print ' <BODY BGCOLOR- "#FFFFFF " TEXT= "#000 000 " LINK= 11 #0 0 0 OFF " 
VL INK= " #AA0 0 AA " ALINK= " #FF 0 0 0 0 " > ' , " \ n " ; 

25 my $results; 

26 open( STUFF, $results_f ilename ) ; 

27 read( STUFF, $results, 1000000) ; 

28 close ( STUFF ) ; 

29 if ($results =~ /ERROR/ | | length ( $results ) == 0 ) { 

30 print "<CENTER>\n" ; 

31 print "<TABLE><TR><TD WIDTH=\ " 80 %\ ">\n u ; 

32 print "<BR><H3>We ' re sorry, but an error occurred attempting to 
extract this geometry .<BR> Please check for overlapping elements and try 

again. </H3>\n"; 

33 print "</TD></TR></TABLE>\n" ; 

34 print ,, </CENTER>\n" ; 

35 print "</BODY></HTML>\n" ; 

36 exit 1; 

37 } 

38 else { 

39 # POST PROCESS RESULTS INTO HTML (THIS IS A PLACEHOLDER) 

40 print "<CENTER>\n" ; 

41 print "<H3>Complete</H3>" ; 

42 print "</CENTER>\n" ; 

43 print "</BODY></HTML>\n" ; 

44 exit 0; 

45 } 



46 sub pretty ( ) { 

47 my $precision = pop(@_); 

48 my $ number = pop(@_); 

49 my $ index = index $ number , "e" , 0 ; 



my $ index = index ^numoer, e ,v; 

if ($index < 0) { $index = index $ number , "E" f 0 ; } 
if ($index>0 && $index > $precision) { 

return substr ( $number , 0 , $precision ) . substr ( $nuinber , $index ) ; 

53 } 

54 else { if ($index>0) { return $number; } 

55 else { return substr ( $number, 0 , $precision ) ; } 

56 } 



50 
51 
52 
53 



57 } 

getsessionid.pl 

1 #! /usr/bin/perl 

2 #Copyright (C) 1997-2000 Rode Consulting, Inc. 

3 #A11 rights reserved. 

4 use strict; 
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5 use MD5; 

6 require ( "project.pl" ) ; 

7 use vars qw( $DOMAIN_NAME $HOST_NAME $HOST_IP $HOST_PREFIX 

$HOST CGI PREFIX); 

"8 " use vars qw( $HOST_PREFIX_JAVA $HOST_CGI_PREFIX__JAVA) ; 

9 use vars qw($BODY $NOCACHE_HEADER $GS $JP2GIF $ ALCHEMY ) ; 

10 use vars qw( %HTML_MACROS ) ; 

11 use vars qw($PROJECT $USAGE_MAX $USAGE_INTERVAL $NUM_RECORDS 
$RECORD_LENGTH) ; 

1 2 require ( " webdate - pi " ) ; 

13 # GLOBALS 

14 use vars qw( $debug ); 

15 use vars qw ( $suid $new__suid $user_id $timestamp $usagestamp Susage 
$valid $path_info $cookie); 

16 my $C00KIE_LENGTH = 35; 

17 #$debug = 1; 

* 18 if ($debug) { 

19 print "Content-type: text/ html\n\n<HTML><BODY><PRE>\n ; 

20 print "path_info: $ENV{ ' PATH_INF0 ' } \ ncookie : $ENV{ ' HTTP_C00KIE ' } \n 

21 } 

22 # Any old random number will do (32 bytes) 

23 my $local_cryptkey = 

i n baceeed5e3ff 05b81b3688clel0b914bd2al518edb6c90 90358eb2 Iccef 6da82 ' ; 

24 sub obscure ( ) { 

25 my $mask = pop @_; 
2 6 my $target = pop @_; 

2 7 my $obscured = " " ; 

28 for (my $i=0; $i<length( $ target ) ; $i++) { 

1 2 9 $obscured .= sprintf( n %lx" , hex( substr ( $target , $i, 1 ) ) 

?hex(substr($mask / $i f 1) ) A hex ( substr ( $local_cryptkey , $i , 1 ) ) ); 

30 } 

31 return $obscured; 

32 } 

33 sub sumcheck() { 

34 my $ source = pop @_; 

35 # my $sum = 'echo $source | mdSsum 2>/dev/null 1 ; 

36 # $sum =- s/\s*-\s*//g; 

37 my $md5 = new MD5 ; 

38 $md5->add($ source. n \n" ) ; 

39 my $sum = unpack( "H32", $md5->digest ( ) ); 

4 0 return $sum; 

41 } 

42 sub encode_suid( ) { 

43 my $usage = pop @_; 
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4 4 my $usagestamp = pop @_; 

45 my $timestamp = pop @_; 

4 6 my $user_id = pop @_; 

47 #open (LOGFILE , "»logf ile" ) ; n 

48 #print LOGFILE "E $user_id $ time stamp $usagestamp $usage\n ; 
4 9 #close (LOGFILE) ; 

50 my $combined = 

$user_id . sprintf { " %08x%08x%04d n , $timestamp, $usagestamp, $usage ) ; 

51 my $sum = &sumcheck( $combined) ; 

52 $sum =~ s/*0*//g; 

53 $sum = substr ($ sum. $ sum, 0 , $COOKIE_LENGTH) ; 

54 my $obscured = &obscure ($ combined, $ sum) ; 

55 return $obscured . $sum; 

56 } 

57 sub decode_suid( ) { 

58 my $encoded = pop @_; 

59 my $unobscured = 

Sobscure ( substr ( $encoded , 0 , $COOKIE__LENGTH ) , substr ( $encoded , $ COOK IE__LENGTH , $COOKIE 

NGTH ) ) ; 

60 my $user_id = substr ( $unobscured, 0 , 15 ) ; 

61 my $timestamp = hex substr ( $unobscured , 15 , 8 ) ; 

62 my $usagestamp = hex substr ( $unobscured, 23 , 8 ) ; 

63 my $usage = hex substr ( $unobscured 7 3 1 , 4 ) ; 

64 #open ( LOGFILE , ">>logf ile" ) ; n 

65 #print LOGFILE "D $user_id $timestamp $usagestamp $usage\n ; 
6 6 #close ( LOGFILE ) ; 

6 7 my $valid = 0; 

68 if ( $encoded eq &encode_suid ( $user_id, $timestamp, $usagestamp, 
$usage) ) { $valid = 1; } 

69 return ($user_id, $timestamp / $usagestamp f $usage, $valid) ; 

70 } 

71 # GET USER_ID, USAGE AND PATH_INFO 

7 2 $path_info = $ENV{ ' PATH_INF0 ' } ; 

73 $path__info =~ s/ [ <> 1 &\~ ] //g; 

74 $path_info =~ s/\.{2 / }//g; # don't allow uptree accesses 

75 $path_info =~ s/\/{2, }/\//g; 

7 6 $path_info =-/()/; # Clear $1 

77 $path_info =~ s#/ ( p\/ ]* )/?##; 

7 8 $ valid = 0; 

79 $suid = ; 

80 if ( $ENV{'HTTP_COOKIE'} =- /SUID2\s*=\s* ( \w* ) / ) { 

81 $suid = $1; 

82 $suid =- s/\s*//g; 

83 ($user_id, $timestamp, $usagestamp, $usage, $valid) = 



&decode_suid( $suid) ; 
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84 # Some of the cookies are cached in a database. 

85 # This code is intended to randomly audit the cookie data 
8 6 # to make sure it isn't corrupt or counterfeited. 

87 sysopen(AUDIT_DB, " auth. dat " , 2) or die( "Can't open authorization 

database! " ) ; 

88 my $hash = &hash ( $user__id) ; 

89 sysseek( AUDIT_DB , $ hash* $RECORD_LENGTH , 0 ); 

90 sysread( AUDIT_DB, my $record, $RECORD__LENGTH- 1 ); # skip newline 

91 (my $prev_user_id, my $prev_time stamp, my $prev_usagestamp, my 
$prev_usage, my $prev__valid) = 

92 &decode_suid( $record) ; 

93 close(AUDIT_DB) ; 

94 if { $prev_valid && ( $prev_user_id eq $user_id) && 

95 ( $prev_usagestamp eq $u sages tamp) && ( $usage < $prev_usage) ) { 

96 $valid = 0; # Apparently the cookie is fake 

97 } 

98 # If more than 24 hours (or some other time limit) has passed, 

99 # reset the usage count 

100 if ( ( time ( ) -$usagestamp ) > $USAGE_INTERVAL ) { 

^ 101 $usagestamp = time(); 

"%i 102 $usage = -1; 

\Fl 103 } 

^ 104 if ($usage > $USAGE_MAX) { 

^ 105 $valid = 0; 

W. 106 } 

107 # DOS inhibition 

108 if ( i ( $ENV{ " HTTP_USER_AGENT " } =- /Mozilla/ ) ) { 
O sleep (15+rand( 10) ) ; return 0; } 

U 109 } 

no else { # No cookie - create a new one 

in (my $ip = $ENV{ " REMOTE_ADDR 11 } ) =~ s/\./:/g; 

Cr n2 (my $a, my $b, my $c, my $d) = split (":",$ ip) ; 

O H3 $ip = ( ( ($a*256+$b)*256+$c)*256+$d); 

ju 114 my $rand = int ( rand( 2**24 )) ; 

115 $user_id = sprintf ( n Z%08x%06x" , $ip, $rand) ; 

116 $usagestamp = time(); 

117 $usage = -1; 

118 } 

119 $new_suid = &encode_suid ( $user_id, time ( ) , $usagestamp, $usage+l); 

12 0 # Expire cookie in 90 days 

121 $cookie = "Set-Cookie: SUID2=$new__suid; 
expires='\&RFC950date(time( ) +7*24*3600 ) ♦ "; path-/cgi-bin/$PROJECT/ ; 
domain=$HOST_IP\n" ; 

122 if ($debug) { print "Using PATHJENFO. . . \n" ; } 

123 if ($debug) { print "SUID: ",$suid," " / "PATH INFO: " , $path_inf o, "\n n ; } 

124 1; 



host.pl 
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1 #! /usr/bin/perl 

2 #Copyright (C) 1997-2000 Rode Consulting, Inc. 

3 #All rights reserved 

4 use strict; 

5 use vars qw( $DOMAIN_NAME $HOST_NAME $HOST_IP $HOST_PREFIX 

$H0ST CGI PREFIX) ; 

6 ~~ use vars qw( $ HOST JPREFIX_ JAVA $HOST_CGI_PREFIX_JAVA) ; 

7 use vars qw($BODY $NOCACHE_HEADER) ; 

8 use vars qw( %HTML_MACROS ) ; 

9 $DOMAIN_NAME="circuitsim.com" ; 

10 $HOST_NAME = " www . " . $DOMAIN_NAME ; 

11 $HOST_IP = "24.218.251.135"; 

12 my $PREFIX = " Stackup/patent" ; 

13 $H0ST PREFIX = " http : / /$HOST_NAME/$PREFIX/ " ; 

14 $HOST~CGI_PREFIX = " http: / / $HOST__NAME/ cgi-bin/ $PREFIX/ " ; 

15 $HOST PREFIX_JAVA = " http: //$HOST_IP/$PREFIX/ " ; 

16 $HOST CGI PREFIX JAVA - " http: //$HOST_IP/cgi-bin/$PREFIX/ " ; 

17 $BODY~= ' <BODY BGCOLOR= "#FFFFFF " TEXT="#000000" LINK="#0000FF n 
VLINK="#AA00AA" ALINK= "#FF0O0 0 "> ' ; 

18 $NOCACHE_HEADER = "Pragma: no-cache\nExpires : Mon, 01 Jul 1996 00:00:00 

GMT\n" ; 

19 $HTML__MACROS { "DOMAIN_NAME " } = ' $DOMAIN_NAME ' ; 

20 $HTML_MACROS { "HOST_NAME" } = ' $HOST_NAME / ; 

21 $HTML_MACROS{"HOST_IP"} = '$HOST_IP'; 

22 $HTML MACROS { "HOST_PREFIX " } = ' $HOST_PREFIX ' ; 

23 $HTML~MACROS{"HOST_CGI_PREFIX"} - ' $HOST_CGI_PREFIX ' ; 

24 $HTML MACROS{"HOST_PREFIX_JAVA"} = ' $HOST_PREFIX_JAVA ' ; 

25 $HTMITmACROS{ "HOST_CGI_JPREFIX_JAVA" } = ' $HOST_CGI_PREFIX_JAVA' ; 

26 $HTML_MACROS { "BODY " } = ' §BODY ' ; 

27 $HTML_MACROS{ "TIME " } = ' $TIME ' ; 

28 $HTML_MACROS{"SESSIONID"} = ' $ session_id ' ; 

29 $HTML_MACROS{"SESSIONIDMACRO"} = ' $session_id_macro ' ; 

30 1; 

makeauth.pl 

1 #! /usr/bin/perl 

2 require ( "project.pl" ) ; 

3 my $nothing = " " ; 

4 for (my $i-0; $ i<$RECORD_LENGTH- 1 ; $i++) { 

5 $ nothing .= " "; 

6 } 

7 open(AUTH, ">auth.dat " ) ; 

8 for (my $i=0; $i<$NUM_RECORDS ; $i++) { 

9 print AUTH $nothing, "\n" ; 

10 } 

project.pl 

1 #! /usr/bin/perl 

2 #Copyright (C) 1997 Rode Consulting, Inc. 

3 #All rights reserved. 
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4 use strict; 

5 use vars qw($PROJECT $USAGE_MAX $USAGE_INTERVAL $NUM_RECORDS 
$RECORD_LENGTH) ; 

6 $PROJECT = "Stackup"; 

7 $USAGE_MAX = 10; 

8 $ US AGE_ INTERVAL = 12*3600; 

9 $NUM_RECORDS = 100 00; 

10 $RECORD_LENGTH =71; 

11 use vars qw( $DOMAIN_NAME $HOST_NAME $HOST__IP $HOST_PREFIX 

$HOST CGI PREFIX) ; 

12 ~ use vars qw( $HOSTJ?REFIX__JAVA $HOST_CGI_PREFIX_JAVA) ; 

13 use vars qw($BODY $NOCACHE__HEADER $GS $JP2GIF $ ALCHEMY) ; 

14 use vars qw( %HTML_MACROS ) ; 

15 # Not a general purpose hash - 

16 # intended to use positions 5-11 inclusive of user_id 

17 sub hash( ) { 

18 my $seed = pop @_; 

19 srand( hex substr ( $seed, 5 , 7 ) ); 

20 return int(rand( $NUM_RECORDS) ) ; 

21 } 

2 2 require ( " hos t . pi " ) ; 

23 1; 

save.pl 

1 #1 /usr/bin/perl 

2 # Copyright 1999-2000 Rode Consulting, Inc. 

3 # All rights reserved 

4 use strict; 

5 require ( "getsessionid.pl" ) ; 

6 use vars qw( $debug ); t . 

7 use vars qw ( $suid $user_id $timestamp $usage $valid $path_m±o 

$cookie) ; 

8 my $cgi query; 

9 read(STDIN, $cgi_query f $ENV{ ' CONTENT_LENGTH ' } ) ; 

10 print "Content-Type: text/plain\n" ; 

11 print "Pragma: no-cache\nExpires : Mon, 01 Jul 1996 00:00:00 GMT\n 

12 print "\n" ; 

13 if (length($user_id) > 0) { 

14 'rm -f tmp/*$user_id* ' ; 

15 open ( STUFF, n >tmp/stuf f " . $user_id. sprintf ( " %04d" , $usage+l ) ) ; 

16 print STUFF $cgi_query; 

17 close(STUFF) ; 

18 print "OK\n"; 

19 } 

20 else { print " ERROR \n" ; } 
webdate .pi 
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1 #! /usr/bin/perl 

2 #Copyright (C) 1997 Rode Consulting, Inc. 

3 #A11 rights reserved. 

4 use strict; 

5 # GLOBAL S 

6 use vars qw( $debug ); 

7 sub zeropad2 { 

8 my $number = pop(@_); 

9 my $ padded; 

10 if ($number < 10) { $padded - " 0 " . $number ; } 

11 else { $padded = " " . $number; } 

12 $padded; 

13 } 

14 sub RFC950date { 

15 my $time - pop(@_); 

16 (my $ sec, my $min,my $hour,my $mday f my $mon,my $year,my $wday,my 
^$yday,my $isdat) = gmtime ( $time ) ; 

17 if ($year < 1970) { $year += 1900; } 
'! is if ($year < 1970) { $year += 100; } 

1 19 # $formatted=' /usr/local/bin/date -d ' $time seconds' '+%A, %d-%b-%y 

1i%T GMT ' — universal'; 
20 

■™ ( "Sunday" , "Monday" , "Tuesday" , "Wednesday" , "Thursday" , "Friday" , "Saturday" ) [ $ wday 

i 21 &zeropad2 ( $mday ) . . 

22 ( "Jan" , "Feb" , "Mar" , "Apr" , "May" , " Jun" , "Jul" , "Aug" , "Sep" , "Oct" , "Nov" , "Dec" ) [ $ mon 

» 3 ] . "-" . 

23 $year . " " . 

_* 24 &zeropad2($hour) . ":" . &zeropad2 ( $min) . " : " . &zeropad2 ( $sec ) . 

V GMT"; 

,..! 25 } 

* 26 sub modified { 

27 my $file = pop(<§_); _ 

28 (my $dev,my $ino,my $mode,my $nlmk,my $uid,my $gxd,my $rdev,my 
$size,my $atime,my $mtime,my $ctime / my $blksize f my $blocks ) = stat($file); 

29 if ($debug) { print "Modified: ",$mtime," " , time ( ) , " \n" ; print $"T; 

* 30 &RFC950date($mtime) ; 

31 } 

32 1; 

native_CrossSection. html 

1 <HTML> 

2 <HEAD> 

3 <TITLE>EXPERIMENTAL PCB Cross Section Editor</TITLE> 

4 </HEAD> 

5 <BODY BGCOLOR= "#FFFFFF " TEXT="#000000 " LINK="#0000FF " VLINK="#AA00AA 
ALINK="#FFO00O"> 
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6 < APPLET CODE="CrossSection.class" CODEBASE= " http : / / <HOST_IP> / Stackup/ " 
ARCHIVE="CrossSection. jar" WIDTH=1024 HEIGHT=540> 

7 <PARAM NAME=addgeometry VALUE =ENABLE> 

8 <PARAM NAME=userid VALUE-" 0000 0000 "> 

9 < / APPLET><BR><BR> 

10 <I — Instructions deleted — > 

11 </BODY> 

12 </HTML> 
nav3_Cr oss Sect ion .html 

1 <HTML> 

2 <HEAD> 

3 <TITLE>EXPERIMENTAL PCB Cross Section Editor</TITLE> 

4 </HEAD> 

5 <BODY BGCOLOR= 11 #FFFFFF " TEXT="#000000" LINK="#0000FF " VLINK="#AA0 0AA 
ALINK="#FF000 0 n > 

6 < APPLET CODE="CrossSection. class" CODEBASE="http : / / <HOST_IP>/ Stackup/ " 
ARCHIVE="CrossSection.zip" WIDTH-1024 HEIGHT=540> 

7 <PARAM NAME=addgeometry VALUE=ENABLE> 

8 <PARAM NAME=userid VALUE=" 00000000 "> 

9 </APPLETXBR><BR> 

10 <! — Instructions deleted — > 

11 </BODY> 

12 </HTML> 

. . / . . /html/Stackup/declined.html 

1 <HTML> 

2 <HEAD><TITLE>Declined</TITLE></HEAD> 

3 <BODY BGCOLOR="#FFFFFF " TEXT="#000000 " LINK="#0000FF" VL I NK= " #AA0 0 AA " 
ALINK= M #FF00 00"> 

4 Sorry you feel that way... 

5 </BODY> 

6 </HTML> 

. ./. ./html/Stackup/error .html 

1 <HTML> 

2 <HEAD> 

3 <TITLE>Extracting geometry. . .</TITLE> 

4 <SCRIPT LANGUAGE= 11 JavaScript " >< i — 

5 badbrowser = (( navigator . appName == "Microsoft Internet Explorer") 
&& ( parselnt( navigator. appVersion) ==4) && ( navigator . appVers ion . indexOf ( "Mac " ) > 

o)); 

6 if (badbrowser) this . focus () ; 

7 if (i badbrowser && window. focus ) this . focus () ; 

8 // — ></SCRIPT> 

9 </HEAD> 

10 <BODY BGCOLOR= "#FFFFFF " TEXT="#0 00000 " LINK="#00 0OFF " VLINK= M #AA00AA" 
ALINK^'^FFOOOO'^ 

11 <TABLE VALIGN=CENTER WIDTH="100%" HEIGHT=" 100% "XTRXTD VALIGN=CENTER 
ALIGN=CENTERXCENTER> 

12 <H2>We're sorry an ERROR occurred in processing your data.<BR> 

13 Please try again later. </H2> 
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14 <H3><I>Cookies must be enabledi</I></H3> 

15 < / CENTERX / TD>< / TR>< / T ABLE> 

16 </BODY> 



17 </HTML> 

. ./. . /html/ Stackup/overuse. html 

1 <HTML> 

2 <HEAD> 

3 <TITLE>Extracting geometry .* .</TITLE> 

4 <SCRIPT LANGUAGE= n JavaScript n ><! — 

5 badbrowser = (( navigator . appName == "Microsoft Internet Explorer 
&& ( par selnt (navigator. appVersion) ==4) && ( navigator . appVersion . indexOf ( "Mac " ) > 
0) ) ; 

6 if (badbrowser) this . focus () ; 

7 if (! badbrowser && window. focus ) this . focus () ; 

8 // — ></SCRIPT> 

9 </HEAD> 

10 <BODY BGCOLOR- "#FFFFFF" TEXT="#000000 " LINK="#0000FF " VLINK="#AA0OAA" 
ALINK="#FF0000 "> 

11 < TABLE VALIGN=CENTER WIDTH- " 100 % " HEIGHT= "100%" XTRXTD VALIGN=CENTER 
; ALIGN=CENTER><CENTER> 

1 12 <H2>We're sorry but you've exceeded your<BR>extraction quota tor 

) today, <BR><BR> 

I 13 Please try again tomorrow . </H2> 

} 14 </CENTER></TDX/TRX/TABLE> 

"l 15 </B0DY> 

1 16 </HTML> 
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